Wizualizacja czasu

Poniższy kod działa tylko na mac os i ma sens jedynie gdy mamy niepolskie ustawienia dat i czasu a chcemy zmienić na polskie. W przypadku właściwych - polskich - ustawień nazwy dni i miesięcy powinny wyświetlać się nam po polsku. Jeśli nazwy są niepolskie kod zmieniający kolejność dni w punkcie o kalendarzach i mapach cieplnych nie będzie działał prawidłowo.

Timeline - oś czasu z wykorzystanie geom_segment

Według Dana Roama autora ksiażki “Narysuj swoje myśli” oś czasu jest modelem wizualnym ilustrującym odpowiedź na pytanie “kiedy” [@roam2010]. Najprościej stworzyć timeline używając funkcji geom_segment() ggplot2.

Biblioteki

library(tidyverse)

## ── Attaching core tidyverse packages ──────────────────────── tidyverse 2.0.0 ──
## ✔ dplyr     1.1.3     ✔ readr     2.1.4
## ✔ forcats   1.0.0     ✔ stringr   1.5.0
## ✔ ggplot2   3.5.0     ✔ tibble    3.2.1
## ✔ lubridate 1.9.3     ✔ tidyr     1.3.0
## ✔ purrr     1.0.2     
## ── Conflicts ────────────────────────────────────────── tidyverse_conflicts() ──
## ✖ dplyr::filter() masks stats::filter()
## ✖ dplyr::lag()    masks stats::lag()
## ℹ Use the conflicted package (<http://conflicted.r-lib.org/>) to force all conflicts to become errors

Dane - Sapkowski i Martin

Użyjemy danych dotyczących dat publikacji i liczby słów w książkach z sag A. Sapkowskiego i G.R.R. Martina.

fantasy <- read_csv("https://raw.githubusercontent.com/Tomasz-Olczyk/wizualizacjaR/main/czas/fantasy.csv")

## New names:
## Rows: 12 Columns: 6
## ── Column specification
## ──────────────────────────────────────────────────────── Delimiter: "," chr
## (2): title, author dbl (4): ...1, number, rok, words
## ℹ Use `spec()` to retrieve the full column specification for this data. ℹ
## Specify the column types or set `show_col_types = FALSE` to quiet this message.
## • `` -> `...1`

fantasy <- read_csv("https://raw.githubusercontent.com/Tomasz-Olczyk/wizualizacjaR/main/czas/fantasy.csv")

## New names:
## Rows: 12 Columns: 6
## ── Column specification
## ──────────────────────────────────────────────────────── Delimiter: "," chr
## (2): title, author dbl (4): ...1, number, rok, words
## ℹ Use `spec()` to retrieve the full column specification for this data. ℹ
## Specify the column types or set `show_col_types = FALSE` to quiet this message.
## • `` -> `...1`

head(fantasy)

Poniższy wykres jest połączeniem wykresu lizakowego (lollypop chart) z osią czasu. Lizaki - słupki a właściwie odcinki zakończone punktem - oznaczać będą daty kolejnych książek

fantasy %>% filter(author == "Martin") %>% 
  # dodaje zmienną disloc, której użyję do mapowania wysokości lizaków
  mutate(disloc = c(0.5, 1, -0.5, -1, 2, 1.5, 0.5)) %>%
ggplot() +
    geom_segment(aes(x = 1990,
                     y = 0, 
                     xend = 2020,
                     yend = 0),
                 arrow = arrow(length = unit(x = 0.2,units = 'cm'),type = 'open'))  +
   geom_segment(aes(x = rok,
                     y = words,
                     xend = rok),
                 yend = 0) +
  geom_point(aes(x = rok,
                   y = words)) +
  geom_text(aes(x = rok,
                  y = words,
                  label = title),
              hjust = 1.0,vjust = 1.0,
              size  = 4) +
  scale_x_continuous(breaks = c(1996, 1999, 2000, 2005, 2011)) +
  theme_minimal() +
    theme(axis.title.x = element_blank(), #usuwa tytuł
          axis.title.y = element_blank(),
          axis.text.y = element_blank(),
          text = element_text(size = 10))

## Warning in geom_segment(aes(x = 1990, y = 0, xend = 2020, yend = 0), arrow = arrow(length = unit(x = 0.2, : All aesthetics have length 1, but the data has 7 rows.
## ℹ Did you mean to use `annotate()`?

## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_segment()`).

## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_point()`).

## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_text()`).

fantasy %>% filter(author == "Martin") %>% 
  # dodaje zmienną disloc, której użyję do mapowania wysokości lizaków
  mutate(disloc = c(0.5, 1, -0.5, -1, 2, 1.5, 0.5)) %>%
ggplot() +
    geom_segment(aes(x = 1990,
                     y = 0, 
                     xend = 2020,
                     yend = 0),
                 arrow = arrow(length = unit(x = 0.2,units = 'cm'),type = 'closed')) +
  geom_segment(aes(x = rok, 
                     y = disloc, 
                     xend = rok), 
                 yend = 0) 

## Warning in geom_segment(aes(x = 1990, y = 0, xend = 2020, yend = 0), arrow = arrow(length = unit(x = 0.2, : All aesthetics have length 1, but the data has 7 rows.
## ℹ Did you mean to use `annotate()`?

## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_segment()`).

fantasy %>% filter(author == "Martin") %>% 
  # dodaje zmienną disloc, której użyję do mapowania wysokości lizaków
  mutate(disloc = c(0.5, 1, -0.5, -1, 2, 1.5, 0.5)) %>%
ggplot() +
    geom_segment(aes(x = rok, 
                     y = disloc, 
                     xend = rok), 
                 yend = 0) + 
  #rysuję oś czasu
    geom_segment(aes(x = 1990,
                     y = 0, 
                     xend = 2020,
                     yend = 0),
                 arrow = arrow(length = unit(x = 0.2,units = 'cm'),type = 'closed')) +
    geom_text(aes(x = rok,
                  y = disloc,
                  label = title), 
              hjust = 1.0,vjust = 1.0,
              size  = 4) +
    geom_point(aes(x = rok,
                   y = disloc)) +
  # kontroluję etykiety na skali ręcznie wybierając tylko lata publikacji książek
    scale_x_continuous(breaks = c(1996, 1999, 2000, 2005, 2011)) +
    theme_minimal() +
    theme(axis.title.x = element_blank(), #usuwa tytuł
          axis.title.y = element_blank(),
          axis.text.y = element_blank(),
          text = element_text(size = 10))

## Warning in geom_segment(aes(x = 1990, y = 0, xend = 2020, yend = 0), arrow = arrow(length = unit(x = 0.2, : All aesthetics have length 1, but the data has 7 rows.
## ℹ Did you mean to use `annotate()`?

## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_segment()`).

## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_text()`).

## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_point()`).

fantasy %>% filter(author == "Martin") %>% 
  # wysokość lizaków = liczba słow
ggplot() +
    geom_segment(aes(x = rok, 
                     y = words, 
                     xend = rok), 
                 yend = 0) + 
  #rysuję oś czasu
    geom_segment(aes(x = 1990,
                     y = 0, 
                     xend = 2020,
                     yend = 0),
                 arrow = arrow(length = unit(x = 0.2,units = 'cm'),type = 'closed')) +
    geom_text(aes(x = rok,
                  y = words,
                  label = title), 
              hjust = 1.0,vjust = 1.0,
              size  = 4) +
    geom_point(aes(x = rok,
                   y = words)) +
  # kontroluję etykiety na skali ręcznie wybierając tylko lata publikacji książek
    scale_x_continuous(breaks = c(1996, 1999, 2000, 2005, 2011)) +
    theme_minimal() +
    theme(axis.title.x = element_blank(), #usuwa tytuł
          axis.title.y = element_blank(),
          axis.text.y = element_blank(),
          text = element_text(size = 10))

## Warning in geom_segment(aes(x = 1990, y = 0, xend = 2020, yend = 0), arrow = arrow(length = unit(x = 0.2, : All aesthetics have length 1, but the data has 7 rows.
## ℹ Did you mean to use `annotate()`?

## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_segment()`).

## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_text()`).

## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_point()`).

Etykiety na skali można także wybrać na podstawie danych:

sapkowski <- fantasy %>% 
  filter(author == "Sapkowski") %>% 
  mutate(disloc = c(0.5, 1, -0.5, -1, 2)) #mniej punktów bo saga Sapkowskiego jest krótsza

ggplot(sapkowski) +
    geom_segment(aes(x = rok, 
                     y = disloc, 
                     xend = rok), 
                 yend = 0) + 
  #rysuję oś czasu
    geom_segment(aes(x = 1990,
                     y = 0, 
                     xend = 2003, #skracam oś czasu bo ostatnia książka jest z 1999
                     yend = 0),
                 arrow = arrow(length = unit(x = 0.2,units = 'cm'),type = 'closed')) +
    geom_text(aes(x = rok,
                  y = disloc,
                  label = title), 
              hjust = 1.0,
              vjust = 1.0,
              size  = 4) +
    geom_point(aes(x = rok,
                   y = disloc)) +
  #kontroluje etykiety na skali ręcznie wybierając tylko lata publikacji książek wykorzystując dane w ramce
    scale_x_continuous(breaks = sapkowski$rok) +
    theme_minimal() +
    theme(axis.title.x = element_blank(), #usuwa tytuł
          axis.title.y = element_blank(),
          axis.text.y = element_blank(),
          text = element_text(size = 10))

## Warning in geom_segment(aes(x = 1990, y = 0, xend = 2003, yend = 0), arrow = arrow(length = unit(x = 0.2, : All aesthetics have length 1, but the data has 5 rows.
## ℹ Did you mean to use `annotate()`?

Zadanie

fantasy %>% 
ggplot() +
    geom_segment(aes(x = rok, y = words,xend = rok, color = author),yend = 0) + # data = data trzeba ustawić globalnie
    geom_segment(aes(x = 1990,
                     y = 0,
                     xend = 2020,
                     yend = 0), 
                 arrow = arrow(length = unit(x = 0.2,
                                             units = 'cm'),
                               type = 'closed')) +
    geom_text(aes(x = rok,y = words,
                  label = title),
              hjust = 1.0,
              vjust = 1.0,
              size  = 4) +
    geom_point(aes(x = rok,
                   y = words,
                   color = author)) +
    theme_minimal() +
    theme(axis.title.x = element_blank(), # element_blank() usuwa dany element motywu
          axis.title.y = element_blank(),
          axis.text.y = element_blank(),
          text = element_text(size = 10))

## Warning in geom_segment(aes(x = 1990, y = 0, xend = 2020, yend = 0), arrow = arrow(length = unit(x = 0.2, : All aesthetics have length 1, but the data has 12 rows.
## ℹ Did you mean to use `annotate()`?

## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_segment()`).

## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_text()`).

## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_point()`).

fantasy %>% 
ggplot() +
    geom_segment(aes(x = rok, y = words,xend = rok, color = author),yend = 0) + # data = data trzeba ustawić globalnie
    geom_segment(aes(x = 1990,
                     y = 0,
                     xend = 2020,
                     yend = 0), 
                 arrow = arrow(length = unit(x = 0.2,
                                             units = 'cm'),
                               type = 'closed')) +
    geom_text(aes(x = rok,y = words,
                  label = title),
              hjust = 1.0,
              vjust = 1.0,
              size  = 4) +
    geom_point(aes(x = rok,
                   y = words,
                   color = author)) +
    theme_minimal() +
    theme(axis.title.x = element_blank(), # element_blank() usuwa dany element motywu
          axis.title.y = element_blank(),
          axis.text.y = element_blank(),
          text = element_text(size = 10))

## Warning in geom_segment(aes(x = 1990, y = 0, xend = 2020, yend = 0), arrow = arrow(length = unit(x = 0.2, : All aesthetics have length 1, but the data has 12 rows.
## ℹ Did you mean to use `annotate()`?

## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_segment()`).

## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_text()`).

## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_point()`).

Wykres panelowy.

fantasy %>% 
  ggplot() +
  geom_segment(aes(x = rok, y = words,xend = rok),yend = 0) + # data = data trzeba ustawić globalnie
  geom_segment(aes(x = 1993,y = 0,xend = 2012,yend = 0),
               arrow = arrow(length = unit(x = 0.2,units = 'cm'),type = 'closed')) +
  geom_text(aes(x = rok,y = words,label = title),   hjust = 0.5,vjust = - 0.5, size  = 4) +
  geom_point(aes(x = rok,
                 y = words)) +
  scale_x_continuous(breaks = c(1994, 1995, 1996, 1997, 1999, 2000,2005, 2011)) +
  scale_y_continuous(limits = c(0, 450000)) +
  theme_bw() +
  labs(y = "słowa") +
  theme(axis.title.x = element_blank(), #usuwa podpis na osi x
       #axis.title.y = element_blank(),
        axis.text.y = element_blank(), # usuwa tekst etykiet na osi y
        text = element_text(size = 15)) +
  facet_wrap(~author, nrow =2)

## Warning in geom_segment(aes(x = 1993, y = 0, xend = 2012, yend = 0), arrow = arrow(length = unit(x = 0.2, : All aesthetics have length 1, but the data has 12 rows.
## ℹ Did you mean to use `annotate()`?

## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_segment()`).

## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_text()`).

## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_point()`).

Wykres Gantta z wykorzystaniem geom_segment

Prosty przykład ramki danych z datami w formie znakowej.

timeline_data <- data.frame(event = c("Event 1", "Event 2"),
                            start = c("2020-06-06", "2020-10-01"), 
                            end   = c("2020-10-01", "2020-12-31"),
                            group = "My Events")

Na poniższym wykresie widać problem z właściwą interpretacją dat w formie napisów:

timeline_data %>%
  ggplot() +
  geom_segment(aes(y = event, #potrzebujemy esetyk y, yend i analogizni z x
                   xend = end, 
                   x= start,
                   yend = event)) +
  theme_bw()

Dlatego zamienimy napisy na daty funkcją as.Date:

timeline_data %>%
  mutate(start = as.Date(start),
         end = as.Date(end)) %>%
 ggplot() +
  geom_segment(aes(y = event, 
                   xend = end, 
                   x= start, 
                   yend = event)) +
  theme_bw()

Ponieważ w moim systeme daty ustawione są na amerykańskie zmieniam ustawienie na polskie.

Ten sam wykres będzie wyglądał inaczej.

timeline_data %>%
  mutate(start = as.Date(start),
         end = as.Date(end)) %>%
 ggplot() +
  geom_segment(aes(y = event, 
                   xend = end, 
                   x= start, 
                   yend = event,
                   color= event), linewidth = 15) +
  theme_bw()

time <- timeline_data %>%
  mutate(start = as.Date(start),
         end = as.Date(end))

Gantt w jednej linii

timeline_data %>%
  mutate(start = as.Date(start),
         end = as.Date(end)) %>%
  ggplot() +
  geom_segment(aes(y = group, 
                   xend = end, 
                   x= start, 
                   yend = group,
                   colour = event)) +
  scale_x_date() +
  theme_bw()

Wykres Gantta rządów III RP

Dane dotyczące długości trwania poszczególnych rządów w IIIRP za wikipedią:

premierzyIIIRP <- read_csv("https://raw.githubusercontent.com/Tomasz-Olczyk/wizualizacjaR/main/czas/premierzyIIIRP.csv")

## Rows: 22 Columns: 7
## ── Column specification ────────────────────────────────────────────────────────
## Delimiter: ","
## chr  (3): nazwisko, stronnictwo, stronnictwo2
## dbl  (2): narodziny, śmierć
## date (2): start, end
## 
## ℹ Use `spec()` to retrieve the full column specification for this data.
## ℹ Specify the column types or set `show_col_types = FALSE` to quiet this message.

premierzyIIIRP <- read_csv("https://raw.githubusercontent.com/Tomasz-Olczyk/wizualizacjaR/main/czas/premierzyIIIRP.csv")

## Rows: 22 Columns: 7
## ── Column specification ────────────────────────────────────────────────────────
## Delimiter: ","
## chr  (3): nazwisko, stronnictwo, stronnictwo2
## dbl  (2): narodziny, śmierć
## date (2): start, end
## 
## ℹ Use `spec()` to retrieve the full column specification for this data.
## ℹ Specify the column types or set `show_col_types = FALSE` to quiet this message.

View(premierzyIIIRP)

Jak widać w ostatniej komórce brakuje daty.

Dla uniknięcia problemów z rysowaniem linii można uzupełnić końcową komórkę w zmiennej end datą systemową funkcją Sys.Date, wewnątrz funkcji ymd z biblioteki lubridate. Komórka znajduje się w 7 kolumnie, w 22 wierszu więc robimy to tak:

premierzyIIIRP[22,7] <- lubridate::ymd(Sys.Date())

z wykorzystanim geom_segment

ggplot(premierzyIIIRP) +
  geom_segment(aes(y = stronnictwo, 
                   xend = end, 
                   x= start,
                   yend = stronnictwo, 
                   colour = stronnictwo),
               linewidth = 10) +
  scale_x_date() +
  theme_bw()

Uporządkujmy wykorzystując funkcję reorder:

ggplot(premierzyIIIRP) +
  geom_segment(aes(y = reorder(stronnictwo, start), 
                   xend = end, 
                   x= start,
                   yend = stronnictwo, 
                   colour = stronnictwo,
                   text = paste("",nazwisko,
                  "<br>",stronnictwo,
                  "<br>objęcie urzędu:",start,
                  "<br>złożenie urzędu:",end),
                  linewidth = 15)) +
  scale_x_date() +
  theme_bw() -> wykres

## Warning in geom_segment(aes(y = reorder(stronnictwo, start), xend = end, :
## Ignoring unknown aesthetics: text

library(plotly)

## 
## Attaching package: 'plotly'

## The following object is masked from 'package:ggplot2':
## 
##     last_plot

## The following object is masked from 'package:stats':
## 
##     filter

## The following object is masked from 'package:graphics':
## 
##     layout

ggplotly(wykres, tooltip = "text")

plotly::ggplotly(z, tooltip = “text”)

Ustalmy etykiety na osi y na zakończenia kadencji (premierzyIIIRP$end).

ggplot(premierzyIIIRP) +
  geom_segment(aes(y = reorder(stronnictwo, start), 
                   xend = end, 
                   x= start,
                   yend = stronnictwo, 
                   colour = stronnictwo)) +
scale_x_date(breaks = (premierzyIIIRP$end), # ustawiamy daty na osi x na koniec danego rządu
               date_labels = "%Y") + #date_labels ustawione na rok
  theme_bw() +
  guides(colour = "none") # wyłączamy legendę

To nie jest dobre rozwiązanie bo daty się nakładają

Dlatego stworzymy wektor z unikalnymi datami rocznymi funkcjami unique i year.

kadencje <- unique(year(premierzyIIIRP$start))

Wektor który uzyskaliśmy ma format numeryczny.

class(kadencje)

## [1] "numeric"

Następnie zmienimy jego format na date

kadencje <- lubridate::ymd(kadencje, 
                                truncated = 2L)

class(kadencje)

## [1] "Date"

plotly::ggplotly(ggplot(premierzyIIIRP) +
  geom_segment(aes(y = reorder(stronnictwo, start), 
                   xend = end, 
                   x= start,
                   yend = stronnictwo, 
                   colour = stronnictwo)) +
  scale_x_date(breaks = kadencje, 
               date_labels = "%Y") +
  theme_bw() +
    guides(colour = "none") 
)

z <- ggplot(premierzyIIIRP) +
  geom_segment(aes(y = reorder(stronnictwo, start), 
                   xend = end, 
                   x= start,
                   yend = stronnictwo, 
                   colour = stronnictwo,
                   text = paste("",nazwisko,
                  "<br>",stronnictwo,
                  "<br>objęcie urzędu:",start,
                  "<br>złożenie urzędu:",end))) +
  scale_x_date(breaks = kadencje, 
               date_labels = "%Y") +
  theme_bw()

## Warning in geom_segment(aes(y = reorder(stronnictwo, start), xend = end, :
## Ignoring unknown aesthetics: text

plotly::ggplotly(z, tooltip = "text")

y <- ggplot(premierzyIIIRP) +
  geom_segment(aes(y = reorder(stronnictwo, start), 
                   xend = end, 
                   x= start,
                   yend = stronnictwo, 
                   colour = stronnictwo,
                   text = paste("",nazwisko,
                  "<br>",stronnictwo,
                  "<br>objęcie urzędu:",start,
                  "<br>złożenie urzędu:",end)),
                  linewidth = 10) + # poszerzymy lini
  scale_x_date(breaks = kadencje, 
               date_labels = "%Y") +
  scale_color_brewer(palette = "Set3") +
  labs(x = "",
       y="",
       title = "Rządy w III RP") +
  theme_bw()

## Warning in geom_segment(aes(y = reorder(stronnictwo, start), xend = end, :
## Ignoring unknown aesthetics: text

y

plotly::ggplotly(y, tooltip = "text") # dodatmy tekst do argumntu tooltip

Dodamy premierów

y1<- ggplot(premierzyIIIRP) +
  geom_segment(aes(y = reorder(stronnictwo, start), 
                   xend = end, 
                   x= start,
                   yend = stronnictwo, 
                   colour = stronnictwo,
                   text = paste("",nazwisko,
                  "<br>",stronnictwo,
                  "<br>objęcie urzędu:",start,
                  "<br>złożenie urzędu:",end)),
                  linewidth = 10) + # poszerzymy lini
  geom_text(aes(y = reorder(stronnictwo, start), 
                   x= start,
            label = nazwisko)) +
  scale_x_date(breaks = kadencje, 
               date_labels = "%Y") +
  scale_color_brewer(palette = "Set3") +
  labs(x = "",
       y="",
       title = "Rządy w III RP") +
  theme_bw()

## Warning in geom_segment(aes(y = reorder(stronnictwo, start), xend = end, :
## Ignoring unknown aesthetics: text

y1

library(ggrepel)

ggplot(premierzyIIIRP) +
  geom_segment(aes(y = reorder(stronnictwo, start), 
                   xend = end, 
                   x= start,
                   yend = stronnictwo, 
                   colour = stronnictwo,
                   text = paste("",nazwisko,
                  "<br>",stronnictwo,
                  "<br>objęcie urzędu:",start,
                  "<br>złożenie urzędu:",end)),
                  linewidth = 10) + # poszerzymy lini
  geom_text_repel(aes(y = reorder(stronnictwo, start), 
                   x= start,
            label = nazwisko)) +
  scale_x_date(breaks = kadencje, 
               date_labels = "%Y") +
  scale_color_brewer(palette = "Set3") +
  labs(x = "",
       y="",
       title = "Rządy w III RP") +
  theme_bw() +
  theme(panel.grid.minor = element_blank()) 

## Warning in geom_segment(aes(y = reorder(stronnictwo, start), xend = end, :
## Ignoring unknown aesthetics: text

library(scales)

## 
## Attaching package: 'scales'

## The following object is masked from 'package:purrr':
## 
##     discard

## The following object is masked from 'package:readr':
## 
##     col_factor

library(lubridate)

timeline z biblioteką timevis

#install.packages("timevis")

library(timevis)

data <- data.frame(
  id      = 1:4,
  content = c("Item one", "Item two",
              "Ranged item", "Item four"),
  start   = c("2016-01-10", "2016-01-11",
              "2016-01-20", "2016-02-14 15:00:00"),
  end     = c(NA, NA, "2016-02-04", NA)
)

timevis(data)

?timevis

próba z timevis

premierzyIIIRP %>%
  rename(content = nazwisko) %>%
  rename(group = stronnictwo) %>% #argument groups i soubgroups pakitu timevis
timevis()

Kalendarz-mapa cieplna z wykorzystaniem geom_tile i facet_wrap dane Oryx

Użyjemy danych na temat sttrat sprzętu wojskowego w Ukrainie:

oryx <- read.csv("https://raw.githubusercontent.com/Tomasz-Olczyk/testowe-repozytrium/main/oryx.csv")

zajrzyjmy do danych:

glimpse(oryx)

## Rows: 664
## Columns: 2
## $ date     <chr> "2022-02-24", "2022-02-25", "2022-02-26", "2022-02-27", "2022…
## $ change_3 <int> NA, 52, 55, 54, 160, 37, 112, 59, 93, 102, 94, 52, 75, 24, 40…

oryx$date jest wektorem napisów a oryx$change_3 liczb całkowitych z wartościami brakującymi

oryx %>% 
  mutate(date = as.Date(date)) %>%
  complete(date = seq.Date(as.Date("2022-02-01"), #funkcja complete tworzy nowe obserwacje, funkcja seq.Date tworzy sekwencję dat
                           as.Date("2023-12-31"), 
                           by="day")) %>% 
  mutate(month = month(date, label = TRUE), 
         wday = wday(date, label = TRUE),
         day = day(date), 
         week = epiweek(date)) -> df1 #operator przypisania może działać także w drugą stronę

x1 <- df1 %>% 
  ggplot(aes(x = wday, y = week, text = paste('straty: ', change_3))) + 
  geom_tile(aes(fill = change_3), color = "black", size = .5) +
  geom_text(aes(label = day)) + 
  labs(title = "Sprzęt utracony na Ukrainie przez Rosjan - dane Oryx", 
       x = "", 
       y = "") + 
  scale_fill_continuous(low = "grey90", 
                       high = "black", 
                     name = "straty dzienne", 
                     na.value = 'white') +
  scale_x_discrete(position = "top") +
  scale_y_continuous(trans = "reverse") + 
  scale_color_manual(values = c("black", "grey")) + 
  facet_wrap(~month, scales="free_y") +
     theme_grey() +
  theme(panel.grid.major = element_blank(), 
        panel.grid.minor = element_blank(), 
        axis.text.y = element_blank(), 
        axis.ticks.y = element_blank(),
        axis.ticks.x = element_blank()) +
    guides(color = "none") 

## Warning: Using `size` aesthetic for lines was deprecated in ggplot2 3.4.0.
## ℹ Please use `linewidth` instead.
## This warning is displayed once every 8 hours.
## Call `lifecycle::last_lifecycle_warnings()` to see where this warning was
## generated.

x1

Epiweek - tydzień zaczyna się od niedzieli:

?epiweek

Sprawdzamy kolejność dni:

levels(df1$wday)

## [1] "ndz" "pon" "wto" "śro" "czw" "ptk" "sob"

oryx %>% 
  mutate(date = as.Date(date)) %>%
  filter(date < "2023-01-01") %>%
  complete(date = seq.Date(as.Date("2022-02-01"), as.Date("2022-12-31"), by="day")) %>% 
  mutate(month = month(date, label = TRUE), 
         wday = wday(date, label = TRUE),
         day = day(date), 
         week = lubridate::isoweek(date)) -> df2 

df2$wday <- factor(df2$wday, levels = c("pon", "wto", "śro", "czw", "ptk", "sob", "ndz"))

Kolejność dni w zmiennej czynnikowej wday musi być zmieniona bo isoweek zaczyna się w poniedziałk

df2$wday <- factor(df2$wday, levels = c("pon", "wto", "śro", "czw", "ptk", "sob", "ndz"))

Sprawdzamy kolejność dni:

levels(df2$wday)

## [1] "pon" "wto" "śro" "czw" "ptk" "sob" "ndz"

x <- df2 %>% 
  ggplot(aes(x = wday, y = week, text = paste('straty: ', change_3))) + 
  geom_tile(aes(fill = change_3), color = "black", size = .5) +
  geom_text(aes(label = day)) + 
  labs(title = "Sprzęt utracony na Ukrainie przez Rosjan - dane Oryx", 
       x = "", 
       y = "") + 
  scale_fill_continuous(low = "grey90", 
                       high = "black", 
                     name = "straty dzienne", 
                     na.value = 'white') +
  scale_x_discrete(position = "top") +
  scale_y_continuous(trans = "reverse") + 
  scale_color_manual(values = c("black", "grey")) + 
  facet_wrap(~month, scales="free_y") +
     theme_grey() +
  theme(panel.grid.major = element_blank(), 
        panel.grid.minor = element_blank(), 
        axis.text.y = element_blank(), 
        axis.ticks.y = element_blank(),
        axis.ticks.x = element_blank()) +
    guides(color = "none")

x

library(plotly)

ggplotly(x, tooltip = "text")

Kalendarz mapa-cieplna a’la github

oryx %>% 
  mutate(date = as.Date(date)) %>%
  #usunę filtrowani na roku
  #filter(date < "2023-01-01") %>%
  complete(date = seq.Date(as.Date("2022-01-01"), as.Date("2023-12-31"), by="day")) %>% 
  mutate(year = year(date),
         month = month(date, label = TRUE),
         months = month(date, label = FALSE),
         wday = wday(date, label = TRUE),
         day = day(date), 
         week = lubridate::isoweek(date)) -> df2 

isowek zaczyna się w poniedziałek:

df2$wday <- factor(df2$wday, levels = c("pon", "wto", "śro", "czw", "ptk", "sob", "ndz"))

ggplot(df2, aes(y = fct_rev(wday), x= week, fill = change_3)) +
  geom_tile(width =7, height = 1, colour = "white") 

ggplot(df2, aes(y = fct_rev(wday), 
                x= week, 
                fill = change_3)) +
  geom_tile(colour = "white") +
  scale_fill_gradient(low = "#BAE177", high ="#155219",
                      na.value = "gray88")

ggplot(df2, aes(y = fct_rev(wday),
                x= week, fill = change_3)) +
  geom_tile(colour = "white") +
  #dodaję skalę kolorów a'la github na podstawi kolorymetru i funkcji rgb
  scale_fill_gradient(low = "#BAE177",
                      high ="#155219",
                      na.value = "gray88") +
  #coord_equal sprawia że rysują się kwadraty a nie prostokąty
  coord_equal() +
  theme_minimal()

ggplot(df2, aes(y = fct_rev(wday),
                x= week, fill = change_3)) +
  geom_tile(colour = "white") +
  #dodaję skalę kolorów a'la github na podstawi kolorymetru i funkcji rgb
  scale_fill_gradient(low = "#BAE177",
                      high ="#155219",
                      na.value = "gray88") +
  #poniższa funkcja sprawia że rysują się kwadraty a nie prostokąty
  coord_equal() + 
  theme_minimal() +
  facet_wrap(~year, nrow =2)

ggplot(df2, aes(y = fct_rev(wday),
                x= week, fill = change_3)) +
  geom_tile(colour = "white") +
  #dodaję skalę kolorów a'la github na podstawi kolorymetru i funkcji rgb
  scale_fill_gradient(low = "#BAE177",
                      high ="#155219",
                      na.value = "gray88") +
  #poniższa funkcja sprawia że rysują się kwadraty a nie prostokąty
  coord_equal() + 
  theme_minimal() +
  facet_wrap(~year, nrow = 2)

miesiące = as.data.frame(table(df2$month))

(y <- ggplot(df2, aes(y = fct_rev(wday),
                x= week, fill = change_3)) +
  geom_tile(colour = "white") +
  #dodaję skalę kolorów a'la github na podstawi kolorymetru i funkcji rgb
  scale_fill_gradient(low = "#BAE177",
                      high ="#155219",
                      na.value = "gray88") +
  #poniższa funkcja sprawia że rysują się kwadraty a nie prostokąty
  coord_equal() + 
  scale_x_continuous(breaks = seq(from =2.5, to = 52, by = 4.333),
                 labels = miesiące$Var1) +
  theme_minimal() +
  facet_wrap(~year, nrow = 2)
)

library(plotly)

ggplotly(y)

Ataki środkami napadu powietrznego na Ukrainę - kalendarz mapa cieplna

Stworzymy kalendarz wzorowany na kalendarzu aktywności na githubie.

Dane dotyczące ataków powietrznych na Ukrainę z Kaggle. Według opisu automatycznie ekstraktowane z komunikatów ukraińskich.

# zbiór missile_attacks z kaggle

ataki_rakietowe <- read_csv("https://raw.githubusercontent.com/Tomasz-Olczyk/wizualizacjaR/main/czas/missile_attacks_daily.csv")

## Rows: 861 Columns: 10
## ── Column specification ────────────────────────────────────────────────────────
## Delimiter: ","
## chr  (7): time_start, model, launch_place, target, destroyed_details, carrie...
## dbl  (2): launched, destroyed
## dttm (1): time_end
## 
## ℹ Use `spec()` to retrieve the full column specification for this data.
## ℹ Specify the column types or set `show_col_types = FALSE` to quiet this message.

#zbiór missiles_and_uav 
środki <- read_csv("https://raw.githubusercontent.com/Tomasz-Olczyk/wizualizacjaR/main/czas/missiles_and_uav.csv")

## Rows: 35 Columns: 9
## ── Column specification ────────────────────────────────────────────────────────
## Delimiter: ","
## chr (9): model, category, national_origin, type, launch_platform, name, name...
## 
## ℹ Use `spec()` to retrieve the full column specification for this data.
## ℹ Specify the column types or set `show_col_types = FALSE` to quiet this message.

ataki_rakietowe <- read_csv("https://raw.githubusercontent.com/Tomasz-Olczyk/wizualizacjaR/main/czas/missile_attacks_daily.csv")

## Rows: 861 Columns: 10
## ── Column specification ────────────────────────────────────────────────────────
## Delimiter: ","
## chr  (7): time_start, model, launch_place, target, destroyed_details, carrie...
## dbl  (2): launched, destroyed
## dttm (1): time_end
## 
## ℹ Use `spec()` to retrieve the full column specification for this data.
## ℹ Specify the column types or set `show_col_types = FALSE` to quiet this message.

środki <- read_csv("https://raw.githubusercontent.com/Tomasz-Olczyk/wizualizacjaR/main/czas/missiles_and_uav.csv")

## Rows: 35 Columns: 9
## ── Column specification ────────────────────────────────────────────────────────
## Delimiter: ","
## chr (9): model, category, national_origin, type, launch_platform, name, name...
## 
## ℹ Use `spec()` to retrieve the full column specification for this data.
## ℹ Specify the column types or set `show_col_types = FALSE` to quiet this message.

Łączymy ramkę danych z ramką opisującą typy środków napadu powietrznego żeby wyselekcjonować ataki z użyciem wybranego typu.

Wybieram model i category z ramki środki:

środki_s <- środki %>%
  select(model, category)

Wybieram czas, model, wystrzelone z ramki ataki:

ataki_s <-  ataki_rakietowe %>% 
  select(time_end, model,launched, destroyed)

Łączę lewym złączeniem (left_join)

ataki_środki <- left_join(ataki_s, środki_s)

## Joining with `by = join_by(model)`

ataki_środki <- ataki_środki %>% 
  mutate(date = as.Date(time_end)) %>%
  complete(date = seq.Date(as.Date("2022-01-01"), 
                           as.Date("2024-03-31"), 
                           by="day")) %>% 
  mutate(year = year(date),
         month = month(date, label = TRUE),
         months = month(date, label = FALSE),
         wday = wday(date, label = TRUE),
         day = day(date), 
         week = lubridate::isoweek(date)) 

Sumy ataków według kategorii

ataki_cat <- ataki_środki %>%
  group_by(date, category) %>%
  summarise(wystrzelone = sum(launched)) %>%
  ungroup()

## `summarise()` has grouped output by 'date'. You can override using the
## `.groups` argument.

manewrujące <- ataki_cat %>%
  filter(category == "cruise missile") %>%
  select(date, wystrzelone)

manewrujące %>%
   complete(date = seq.Date(as.Date("2022-09-28"), as.Date("2024-03-30"), by="day")) %>% 
  mutate(year = year(date),
         month = month(date, label = TRUE),
         months = month(date, label = FALSE),
         wday = wday(date, label = TRUE),
         day = day(date), 
         week = lubridate::epiweek(date))  -> df7 

Manewrujące

 ggplot(df7, aes(y = fct_rev(wday),
                x= week, 
                fill = wystrzelone)) +
  geom_tile(colour = "white", 
            linewidth = 1) +
  #dodaję skalę kolorów a'la github na podstawi kolorymetru i funkcji rgb
  scale_fill_gradient(low = "orange",
                      high ="red4",
                      na.value = "gray88") + # wygląda na to że w 2024 nie ma na value
  #poniższa funkcja sprawia że rysują się kwadraty a nie prostokąty
  coord_equal() + 
  scale_x_continuous(breaks = seq(from =1.5, to = 52, by = 4.333), labels = c("sty", "lut", "mar", "kwi", "maj", "cze", "lip", "sie", "wrz", "paź", "lis", "gru"), 
                     position = "bottom") +
  theme_minimal() +
  facet_wrap(~year, ncol = 1) +
   theme(panel.grid = element_blank(),
         axis.title.y = element_blank(),
         axis.title.x = element_blank(),
         legend.position = "bottom",
         legend.justification = "right") +
   guides(fill = guide_legend(title.position = "left", 
                              label.position = "bottom",
                              keywidth = 1, 
                              nrow = 1)) +
  labs(title = "Rosyjskie ataki pociskami manewrującymi od 28 września 2022",
       caption = "źródło: https://www.kaggle.com/datasets/piterfm/massive-missile-attacks-on-ukraine")

Balistyczne

balistyczne <- ataki_cat %>%
  filter(category == "ballistic missile") %>%
  select(date, wystrzelone)

balistyczne %>%
   complete(date = seq.Date(as.Date("2022-09-28"), as.Date("2024-03-30"), by="day")) %>% 
  mutate(year = year(date),
         month = month(date, label = TRUE),
         months = month(date, label = FALSE),
         wday = wday(date, label = TRUE),
         day = day(date), 
         week = lubridate::epiweek(date))  -> bdf 

b <- ggplot(bdf, aes(y = fct_rev(wday),
                x= week, 
                fill = wystrzelone)) +
  geom_tile(colour = "white", 
            linewidth = 1) +
  #dodaję skalę kolorów a'la github na podstawi kolorymetru i funkcji rgb
  scale_fill_gradient(low = "orange",
                      high ="red4",
                      na.value = "gray88") + # wygląda na to że w 2024 nie ma na value
  #poniższa funkcja sprawia że rysują się kwadraty a nie prostokąty
  coord_equal() + 
  scale_x_continuous(breaks = seq(from =1.5, to = 52, by = 4.333), labels = miesiące$Var1,
                     position = "bottom") +
  theme_gray() +
  facet_wrap(~year, ncol = 1) +
   theme(panel.grid = element_blank(),
         axis.title.y = element_blank(),
         axis.title.x = element_blank(),
         legend.position = "bottom",
         legend.justification = "right") +
   guides(fill = guide_legend(title.position = "left", 
                              label.position = "bottom",
                              keywidth = 1, 
                              nrow = 1)) +
  labs(title = "Rosyjskie ataki pociskami balistycznymi od 28 września 2022",
       caption = "źródło: https://www.kaggle.com/datasets/piterfm/massive-missile-attacks-on-ukraine")

b <- ggplot(bdf, aes(y = fct_rev(wday),
                x= week, 
                fill = wystrzelone)) +
  geom_tile(colour = "white", 
            linewidth = 1) +
  #dodaję skalę kolorów a'la github na podstawi kolorymetru i funkcji rgb
  scale_fill_gradient(low = "orange",
                      high ="red4",
                      na.value = "gray") + # 
  #poniższa funkcja sprawia że rysują się kwadraty a nie prostokąty
  coord_equal() + 
  scale_x_continuous(breaks = seq(from =1.5, to = 52, by = 4.333), labels = miesiące$Var1,
                     position = "bottom") +
  theme_minimal() +
  facet_wrap(~year, ncol = 1) +
   theme(axis.title.y = element_blank(),
         axis.title.x = element_blank(),
         legend.position = "bottom",
         legend.justification = "right") +
   guides(fill = guide_legend(title.position = "left", 
                              label.position = "bottom",
                              keywidth = 1, 
                              nrow = 1)) +
  labs(title = "Rosyjskie ataki pociskami balistycznymi od 28 września 2022",
       caption = "źródło: https://www.kaggle.com/datasets/piterfm/massive-missile-attacks-on-ukraine")

b

ggplotly(b)

## Warning in min(x): no non-missing arguments to min; returning Inf

## Warning in max(x): no non-missing arguments to max; returning -Inf

## Warning in matrix(g$fill_plotlyDomain, nrow = length(y), ncol = length(x), :
## data length [365] is not a sub-multiple or multiple of the number of rows [7]

## Warning in matrix(g$hovertext, nrow = length(y), ncol = length(x), byrow =
## TRUE): data length [365] is not a sub-multiple or multiple of the number of rows
## [7]

## Warning in colorscale_json(trace$colorscale): A colorscale list must of elements
## of the same (non-zero) length

Kalendarz z danych o rakietach

bdf %>% 
  ggplot(aes(x = wday, y = week)) + 
  geom_tile(aes(fill = wystrzelone), color = "black", size = .5) +
  geom_text(aes(label = day)) + 
  labs(title = "Rakiety balistyczne wystrzelone przez Rosję", 
       x = "", 
       y = "") + 
  scale_fill_continuous(low = "grey90", 
                       high = "black", 
                     name = "straty dzienne", 
                     na.value = 'white') +
  scale_x_discrete(position = "top") +
  scale_y_continuous(trans = "reverse") + 
  scale_color_manual(values = c("black", "grey")) + 
  facet_grid(year~month) +
     theme_grey() +
  theme(panel.grid.major = element_blank(), 
        panel.grid.minor = element_blank(), 
        axis.text.y = element_blank(), 
        axis.ticks.y = element_blank(),
        axis.ticks.x = element_blank()) +
    guides(color = "none") 

levels(bdf$wday)

## [1] "ndz" "pon" "wto" "śro" "czw" "ptk" "sob"

balistyczne %>%
   complete(date = seq.Date(as.Date("2022-09-28"), as.Date("2024-03-30"), by="day")) %>% 
  mutate(year = year(date),
         month = month(date, label = TRUE),
         months = month(date, label = FALSE),
         wday = wday(date, label = TRUE),
         day = day(date), 
         week = lubridate::isoweek(date))  -> bdf_iso

bdf %>% 
  filter(year == 2023) %>%
  ggplot(aes(x = wday, y = week)) + 
  geom_tile(aes(fill = wystrzelone), color = "black", size = .5) +
  geom_text(aes(label = day)) + 
  labs(title = "Rakiety balistyczne wystrzelone przez Rosję", 
       x = "", 
       y = "") + 
  scale_fill_continuous(low = "grey90", 
                       high = "black", 
                     name = "straty dzienne", 
                     na.value = 'white') +
  scale_x_discrete(position = "top") +
  scale_y_continuous(trans = "reverse") + 
  scale_color_manual(values = c("black", "grey")) + 
  facet_wrap(~month, scales="free_y") +
     theme_grey() +
  theme(panel.grid.major = element_blank(), 
        panel.grid.minor = element_blank(), 
        axis.text.y = element_blank(), 
        axis.ticks.y = element_blank(),
        axis.ticks.x = element_blank()) +
    guides(color = "none") 

bdf_iso$wday <- factor(bdf_iso$wday, levels = c("pon", "wto", "śro", "czw", "ptk", "sob", "ndz"))

bdf_iso$week[bdf_iso$month=="sty" & bdf_iso$week ==52] = 0

bdf_iso %>% 
  filter(year == 2023) %>%
  ggplot(aes(x = wday, y = week)) + 
  geom_tile(aes(fill = wystrzelone), color = "black", size = .5) +
  geom_text(aes(label = day)) + 
  labs(title = "Rakiety balistyczne wystrzelone przez Rosję", 
       x = "", 
       y = "") + 
  scale_fill_continuous(low = "grey90", 
                       high = "black", 
                     name = "straty dzienne", 
                     na.value = 'white') +
  scale_x_discrete(position = "top") +
  scale_y_continuous(trans = "reverse") + 
  scale_color_manual(values = c("black", "grey")) + 
  facet_wrap(~month, scales="free_y") +
     theme_grey() +
  theme(panel.grid.major = element_blank(), 
        panel.grid.minor = element_blank(), 
        axis.text.y = element_blank(), 
        axis.ticks.y = element_blank(),
        axis.ticks.x = element_blank()) 

test <- bdf_iso %>% 
  filter(year == 2023,
         months == 1)

test3 <- bdf %>% 
  filter(year == 2023,
         months == 12)

test4 <- df2 %>% 
  filter(year == 2023,
         months == 1)

epiweek(ymd("2022-01-01"))

## [1] 52

#install.packages("calendR")

library(calendR)

## ~~ Package calendR
## Visit https://r-coder.com/ for R tutorials ~~

# Data
set.seed(2)
data <- rnorm(365)

dat <- bdf %>% 
  filter(year == 2023) %>%
  select(wystrzelone) 

dat[is.na(dat)] <- 0

# Calendar
calendR(year = 2023,
        special.days = dat$wystrzelone,
        gradient = TRUE,
        low.col = "#FCFFDD",
        special.col = "#00AAAE",
        legend.pos = "right",
        legend.title = "Title")

stock.data <- transform(bdf,
  tydz = as.POSIXlt(date)$yday %/% 7 + 1,
  dz = as.POSIXlt(date)$wday,
  yrok = as.POSIXlt(date)$year)

library(ggplot2)

ggplot(stock.data, aes(tydz, dz, fill = wystrzelone)) + 
geom_tile(colour = "white") + 
scale_fill_gradientn(colours = c("#D61818","#FFAE63","#FFFFBD","#B5E384")) + 
 facet_wrap(~ year, ncol = 1) +
  coord_equal()

stock.data %>% 
  ggplot(aes(x = dz, y = tydz)) + 
  geom_tile(aes(fill = wystrzelone), color = "black", size = .5) +
  geom_text(aes(label = dz)) + 
  labs(title = "Rakiety balistyczne wystrzelone przez Rosję", 
       x = "", 
       y = "") + 
  scale_fill_continuous(low = "grey90", 
                       high = "black", 
                     name = "straty dzienne", 
                     na.value = 'white') +
  scale_x_discrete(position = "top") +
  scale_y_continuous(trans = "reverse") + 
  scale_color_manual(values = c("black", "grey")) + 
  facet_grid(year~month, scales="free_y") +
     theme_grey() +
  theme(panel.grid.major = element_blank(), 
        panel.grid.minor = element_blank(), 
        axis.text.y = element_blank(), 
        axis.ticks.y = element_blank(),
        axis.ticks.x = element_blank()) 

qplot(week, Adj.Close, data = stock.data, colour = factor(wday), geom = “line”) + facet_wrap(~ year, ncol = 1)

df  <-  tibble(
  DateCol = seq(
    dmy("01/01/2022"),
    dmy("31/12/2022"),
    "days"
  ),
  ValueCol = runif(365)
)

dfPlot <- df %>% 
  mutate(weekday = wday(DateCol, label = T, week_start = 7), # can put week_start = 1 to start week on Monday
         month = month(DateCol, label = T),
         date = yday(DateCol),
         week = epiweek(DateCol))

# isoweek makes the last week of the year as week 1, so need to change that to week 53 for the plot
dfPlot$week[dfPlot$month=="sty" & dfPlot$week ==52] = 0 

dfPlot <- dfPlot %>% 
  group_by(month) %>% 
  mutate(monthweek = 1 + week - min(week))

dfPlot %>%  
  ggplot(aes(weekday,-week, fill = ValueCol)) +
  geom_tile(colour = "white")  + 
  theme(aspect.ratio = 1/5,
        axis.title.x = element_blank(),
        axis.title.y = element_blank(),
        axis.text.y = element_blank(),
        panel.grid = element_blank(),
        axis.ticks = element_blank(),
        panel.background = element_blank(),
        strip.background = element_blank(),
        strip.text = element_text(face = "bold", size = 15),
        panel.border = element_rect(colour = "black", fill=NA, size=1)) +
  facet_wrap(~month, nrow = 4, ncol = 3, scales = "free") 

## Warning: The `size` argument of `element_rect()` is deprecated as of ggplot2 3.4.0.
## ℹ Please use the `linewidth` argument instead.
## This warning is displayed once every 8 hours.
## Call `lifecycle::last_lifecycle_warnings()` to see where this warning was
## generated.

sty <- dfPlot %>% filter(month == "sty")